PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/tools/allocrj.com/ALLOC.PAS

Pascal/Delphi Source File | 1989-04-09 | 11.9 KB | 380 lines

{**************************************************************************
  Some of the DOS memory routines presented in ALLOC.PAS and demonstrated
  in ALLOCDEM.PAS, were initially uploaded by Richard Sadowsky as DOSMEM
  (version 1.1), and released to the public domain on 8/22/88.  That
  unit was especially appreciated by those of us who code in both
  Turbo Pascal and Turbo C.  30-40% of the code in the ALLOC unit was
  taken from DOSMEM.

  However, DOSMEM had its DOS routines written in assembly language,
  and required use as external *.obj files.  Since I frequently forget
  *.obj files when I'm working at differenct locations, and more importantly,
  since I'm not good at assembly, I re-wrote the routines using interrupts,
  calling the new unit ALLOC.PAS, in deference to Turbo C's <alloc.h>.  In
  addition, a few other modifications were made to the error-handling routine,
  as well as making the interrupt routines internal to the unit, re-naming
  a few things, and adding calloc, which has as its argument, the desired
  fillpattern with which to clear the RAM block (unlike C's calloc).

  modification history:
    1. v1.1 adapted from MEMDOS 1.1 changing assembly to MsDos calls.
    2. v1.2 reorganized unit, changed error handling.
    3. v1.3 added calloc, expanded demo.
    4. v1.4 :
       a. the "carry" register flag is now monitored in the internal routines
            for errors, rather than examing AX for values 7-9.
       b. returns a variable pointer (re-set to NIL) in the free() and
            farfree() procedures.
       c. prevents freeing a previously freed pointer and reallocating
            a pointer assiged to NIL, and encourages initialization of
            memory pointers to NIL prior to use in order to avoid
            unpredictable results from DOS (see demo).
       d. corrected a bug in initvideo() which should use Mem[], not MemW[].
       e. MallocError renamed to AllocError.
       f. expanded comments.

  Robert L. Jones,  CIS [71251,2566]

  Version 1.4 released to the public domain 4/9/89.


  ---------------------------------------------------------------------------
  A comment on ALLOC and TP's heap:

  The ALLOC unit cannot be used without some planning.  In order to access
  DOS using Int 21, the memory compiler option for Turbo Pascal needs to be
  used to provide sufficient memory for DOS to allocate RAM.  That is, without
  an upper limit on the heap size, Turbo Pascal will assign any extra RAM,
  which it doesn't use, to the heap.  If all of the available RAM is thus
  assigned to the heap, then no RAM will be accessible to the ALLOC routines
  (i.e., for use by DOS).  This does not mean that a portion cannot be
  retained for use on the heap, rather it implies that enough RAM must be
  available for DOS if you want to allocate some of it using ALLOC.

  For example, see the memory compiler option at the start of the demo:

    $M 1024,0,0  <- the last digit sets the maximum value assigned for
                    the heap.  this value could have easily been 10000,
                    but then 10000 bytes less would be available for ALLOC.

***************************************************************************}

unit ALLOC;

interface

uses Dos;

const
  { the array is set at 7-9 due to the 3 possible errors returned in AX }
  MemError : array [7..9] of string[40] =
             ('Memory Control Blocks Destroyed',
              'Insufficient Memory','Invalid Segment Specified');
var
  AllocError  : byte;

function  malloc  (SizeInBytes : word) : pointer;
function  calloc  (fillpattern : byte; SizeInBytes : word) : pointer;
function  realloc (p : pointer; NewSizeInBytes : word) : pointer;
procedure free    (var p : pointer);
procedure farfree (var p : pointer);
function  coreleft : word;
function  farmalloc  (SizeInBytes : longint) : pointer;
function  farcalloc  (fillpattern : byte; SizeInBytes : longint) : pointer;
function  farrealloc (p : pointer; NewSizeInBytes : longint) : pointer;
function  farcoreleft : longint;


implementation

{**************************************************************************
  Internal routines for allocating RAM.  DOS Intr 21h is called.

  If the request allocation, reallocation, or freeing is successful,
  AllocError is set to 0. If an error occurs [insufficient memory (8),
  control block damage (7), or invalid segment (9)], AllocError is
  set accordingly.  The error is indicated by the Carry Flag record of
  the register, which is determined by AND'ing with the Turbo Pascal
  constant FCarry.  If the Carry Flag is clear then everything is OK, and
  0 is returned.  If the Carry Flag is not clear, then AX contains the
  error code (7, 8, or 9), and this value is returned instead of 0.
***************************************************************************}

type
  PtrPtr       = ^pointer;
var
  regs : registers;


function DosAlloc (SizeInParas : word;
                   var Largest : word;
                   var Segment : word) : integer;
{
  low level dos memory allocation function.  This function
  calls DOS function 48h to allocate the specified number
  of paragraphs.  The maximum number of free paragraphs is
  returned in BX if the number of paragraphs requested is
  greater than the amount of memory free.  Only the segment
  of the allocated memory is returned (because the offset is
  always 0).
}
begin
  with regs do begin
    ah := $48;
    bx := SizeInParas;
    MSDOS(regs);
    if (flags AND FCarry = 0) then begin
      { request was successful }
      Segment := ax;
      Largest := bx;
      DosAlloc := 0;
    end
    else begin
      { if insufficient memory for requested block, return largest possible }
      if (ax = $08) then
        Largest := bx
      else
        Largest := 0;
      DosAlloc := ax;
    end;
  end;
end;


function DosFree (Segment : word) : integer;
{
  low level dos memory free routine.  This function calls
  DOS function 49h to free memory previously allocated with
  DosAlloc (DOS function 48h).
}
begin
  with regs do begin
    ah := $49;
    es := Segment;
    MSDOS(regs);
    if (flags AND FCarry = 0) then
      { request was successful }
      DosFree := 0
    else
      DosFree := ax;
  end;
end;


function DosRealloc (NewSizeInParas : word;
                     var Largest    : word;
                     var Segment    : word) : integer;
{
  low level dos memory reallocation routine.  This function calls
  DOS function 4Ah to realloc memory previously allocated with
  DosAlloc (DOS function 48h).
}
begin
  with regs do begin
    ah := $4A;
    bx := NewSizeInParas;
    es := Segment;
    MSDOS(regs);
    if (flags AND FCarry = 0) then begin
      { request was successful }
      Segment := ax;
      Largest := bx;
      DosRealloc := 0;
    end
    else begin
      { if insufficient memory for requested block, return largest possible }
      if (ax = $08) then
        Largest := bx
      else
        Largest := 0;
      DosRealloc := ax;
    end;
  end;
end;




{**************************************************************************
  External routines for allocating RAM.  Pointers are returned as NIL if
  the memory request was unsuccessful (AllocError <> 0).
***************************************************************************}

function malloc (SizeInBytes : word) : pointer;
var
  L,Segment,SizeInP : word;
begin
  { divide size in bytes by 16 to get paragraphs }
  SizeInP := SizeInBytes SHR 4;
  { if size in bytes not evenly ÷ by 16, add 1 }
  if SizeInBytes MOD 16 <> 0 then inc(SizeInP);
  { try to allocate memory }
  AllocError := DosAlloc(SizeInP,L,Segment);
  if (AllocError = 0) then
    {return ptr to allocated memory }
    malloc := ptr(Segment,0)
  else
    malloc := NIL;
end;


function calloc (fillpattern : byte; SizeInBytes : word) : pointer;
var
  L,Segment,SizeInP,i : word;
  p : pointer;
begin
  SizeInP := Word(SizeInBytes SHR 4);
  if SizeInBytes MOD 16 <> 0 then inc(SizeInP);
  AllocError := DosAlloc(SizeInP,L,Segment);
  if (AllocError = 0) then begin
    p := ptr(Segment,0);
    calloc := p;
    fillchar(p^, SizeInBytes, fillpattern);
    end
  else
    calloc := NIL;
end;


function realloc (p : pointer; NewSizeInBytes : word) : pointer;
var
  L,Segment,SizeInP : word;
begin
  { prevent reallocating a pointer not assigned by malloc()/calloc() }
  if (p = NIL) then begin
    AllocError := $09;
    realloc := NIL;
    exit;
    end;
  SizeInP := NewSizeInBytes SHR 4;
  if NewSizeInBytes MOD 16 <> 0 then inc(SizeInP);
  Segment := Seg(PtrPtr(p)^);
  AllocError := DosRealloc(SizeInP,L,Segment);
  if (AllocError = 0) then
    realloc := ptr(Segment,0)
  else
    realloc := NIL;
end;


procedure free (var p : pointer);
begin
  { return error if unable to free memory; reset p to NIL. }
  { in addition, a check is done to avoid "freeing" an already freed pointer }
  if (p = NIL) then begin
    AllocError := $09;
    exit;
    end;
  AllocError := DosFree(Seg(PtrPtr(p)^));
  p := NIL;
end;


function coreleft : word;
var
  Largest, Segment : word;
  Err              : byte;
begin
  { since you can't allocate FFFFh paragraphs on a 640K machine, this }
  { request will always generate an error, and return the largest free }
  { blocks currently available }
  Err := DosAlloc($FFFF, Largest, Segment);
  coreleft := Largest;
end;




{*****************************************************************************
  FAR memory routines for allocating large blocks of RAM
      (up to all of free ram)

  These routine are the same as above, except LONGINTs are used to represent
  the memory size in bytes, not paragraphs.  With LONGINTs, up to all of free
  memory can be allocated with a single call (and therefore, a contiguous
  block of memory).
******************************************************************************}

function farmalloc (SizeInBytes : longint) : pointer;
var
  L,Segment,SizeInP : word;
begin
  SizeInP := Word(SizeInBytes SHR 4);
  if SizeInBytes MOD 16 <> 0 then inc(SizeInP);
  AllocError := DosAlloc(SizeInP,L,Segment);
  if (AllocError = 0) then
    farmalloc := ptr(Segment,0)
  else
    farmalloc := NIL;
end;


function farcalloc (fillpattern : byte; SizeInBytes : longint) : pointer;
var
  L,Segment,SizeInP : word;
  p : pointer;
begin
  SizeInP := Word(SizeInBytes SHR 4);
  if SizeInBytes MOD 16 <> 0 then inc(SizeInP);
  AllocError := DosAlloc(SizeInP,L,Segment);
  if (AllocError = 0) then begin
    p := ptr(Segment,0);
    farcalloc := p;
    fillchar(p^, SizeInBytes, fillpattern);
    end
  else
    farcalloc := NIL;
end;


function farrealloc (p : pointer; NewSizeInBytes : longint) : pointer;
var
  L,Segment,SizeInP : word;
begin
  { prevent farreallocating a pointer not assigned by farmalloc()/farcalloc() }
  if (p = NIL) then begin
    AllocError := $09;
    farrealloc := NIL;
    exit;
    end;
  SizeInP := Word(NewSizeInBytes SHR 4);
  if NewSizeInBytes MOD 16 <> 0 then inc(SizeInP);
  Segment := Seg(PtrPtr(p)^);
  AllocError := DosRealloc(SizeInP,L,Segment);
  if (AllocError = 0) then
    farrealloc := ptr(Segment,0)
  else
    farrealloc := NIL;
end;


function farcoreleft : longint;
var
  Largest, Segment : word;
  Err              : byte;
begin
  Err := DosAlloc($FFFF, Largest, Segment);
  farcoreleft := longint (Largest) SHL 4;
end;


procedure farfree (var p : pointer);
{
  a thoroughtly unnecessary procedure, since free() does exactly the same
  thing due to the fact that pointers and longints are 32-bits long.
  but heh, why not maintain consistency?
  as with free(), p is reset to NIL to tell the user what happened.
}
begin
  if (p = NIL) then begin
    AllocError := $09;
    exit;
    end;
  AllocError := DosFree(Seg(PtrPtr(p)^));
  p := NIL;
end;


begin
  { ALLOC }
end.